home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / mipsco_link.t < prev    next >
Text File  |  1989-06-30  |  12KB  |  346 lines
  1. (herald mipsco_link (env t (link defs)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (link modules out-spec)
  6.   (really-link modules 'mbo out-spec 'o))
  7.  
  8. (define-constant RELOC-SIZE 8)
  9. (define-constant MAGIC #x160)
  10. (define-constant TEXT-SYM 1)
  11. (define-constant DATA-SYM 3)
  12.  
  13. (lset reloc-length 0)
  14. (lset pure-size 0)
  15.  
  16. (define-constant %%d-ieee-size 53)
  17. (define-constant %%d-ieee-excess 1023)
  18.  
  19. (define (write-double-float stream float)
  20.   (receive (sign mantissa exponent)
  21.            (normalized-float-parts float
  22.                                    %%d-ieee-size 
  23.                                    %%d-ieee-excess 
  24.                                    t)
  25.     (write-int stream header/double-float)
  26.     (write-half stream (fx+ (fixnum-ashl sign 15)
  27.                             (fx+ (fixnum-ashl exponent 4)
  28.                                  (bignum-bit-field mantissa 48 4))))
  29.     (write-half stream (bignum-bit-field mantissa 32 16)) 
  30.     (write-half stream (bignum-bit-field mantissa 16 16)) 
  31.     (write-half stream (bignum-bit-field mantissa 0 16))))
  32.   
  33. (define (write-vcell-header var stream)
  34.   (write-half stream 0)
  35.   (write-byte stream (if (fx= (vector-length (var-node-refs var))
  36.                   0)
  37.              0
  38.              -1))
  39.   (write-byte stream (if (eq? (var-node-defined var) 'define)
  40.              (fx+ header/vcell 128)
  41.              header/vcell)))
  42.  
  43.   
  44.  
  45. (define (vgc-copy-foreign foreign)
  46.   (let* ((heap (lstate-impure *lstate*))
  47.          (addr (area-frontier heap))
  48.          (name (foreign-object-name foreign))
  49.          (desc (object nil
  50.                  ((heap-stored self) (lstate-impure *lstate*))
  51.                  ((heap-offset self) addr)
  52.                  ((write-descriptor self stream)
  53.                   (write-data stream (fx+ addr tag/extend)))
  54.                  ((write-store self stream)
  55.                   (write-int stream header/foreign)
  56.                   (write-slot name stream)
  57.                   (write-int stream 0)))))
  58.     (set (area-frontier heap) (fx+ addr 12))
  59.     (set-table-entry *reloc-table* foreign desc)
  60.     (generate-slot-relocation name (fx+ addr 4))
  61.     (push (area-objects heap) desc)                
  62.     (cymbal-thunk (symbol->string name) 0)
  63.     (reloc-thunk (fx+ addr 8) (lstate-symbol-count *lstate*) 5)
  64.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  65.     desc))
  66.  
  67. (define (relocate-unit-variable var addr external?)
  68.   (let ((area (lstate-impure *lstate*))
  69.         (type (var-value-type var)))
  70.    (cond (type
  71.     (cond ((and external? (neq? (var-node-value var) NONVALUE))
  72.            (cymbal-thunk (string-downcase! (symbol->string (var-node-name var)))
  73.                          (unit-var-value (var-node-value var)))
  74.            (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  75.     (if (fx= type DATA-SYM)
  76.         (reloc-thunk addr DATA-SYM 4)
  77.         (reloc-thunk addr TEXT-SYM 4))))))
  78.  
  79.  
  80. (define (var-value-type var)
  81.   (let ((value (var-node-value var)))
  82.     (cond ((eq? value NONVALUE) 
  83.            (vgc (var-node-name var))
  84.            nil)
  85.           ((unit-loc? value) DATA-SYM)
  86.           (else
  87.            (let ((desc (vgc value)))
  88.              (if (eq? (heap-stored desc) (lstate-impure *lstate*))
  89.                  DATA-SYM                                                                
  90.                  TEXT-SYM))))))
  91.  
  92. (define (generate-slot-relocation obj slot-address)
  93.   (cond ((or (fixnum? obj) (char? obj) (eq? obj '#t)))
  94.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  95.          (reloc-thunk slot-address DATA-SYM 4))
  96.         (else
  97.          (reloc-thunk slot-address TEXT-SYM 4))))
  98.  
  99. (define (text-relocation addr)
  100.   (reloc-thunk addr TEXT-SYM 4))
  101.  
  102. (define (data-relocation addr)
  103.   (reloc-thunk addr DATA-SYM 4))
  104.  
  105. (define (reloc-thunk address lw hb)
  106.   (push (lstate-data-reloc *lstate*)
  107.         (cons address (cons lw hb))))
  108.             
  109. (lset the-string-table nil)
  110.  
  111. (define (cymbal-thunk stryng value)
  112.  (push (lstate-symbols *lstate*)
  113.   (object (lambda (stream)
  114.         (write-int stream 0)
  115.         (write-int stream (table-entry the-string-table stryng))
  116.             (cond ((fx= value 0)            ; undefined external (foreign)
  117.            (write-int stream 0)
  118.            (write-half stream #x4cf))
  119.           (else
  120.            (write-data stream value)
  121.            (write-half stream #x44f)))
  122.         (write-half stream #xffff))
  123.           ((cymbal-thunk.stryng self) stryng))))
  124.  
  125. (define-operation (cymbal-thunk.stryng thunk))
  126.  
  127.  
  128. (define (write-slot obj stream)
  129.   (cond ((table-entry *reloc-table* obj)
  130.          => (lambda (desc) (write-descriptor desc stream)))
  131.         ((fixnum? obj)
  132.          (write-fixnum stream obj))
  133.         ((char? obj)
  134.          (write-int stream (fx+ (fixnum-ashl (char->ascii obj) 8)
  135.                                  header/char)))
  136.         ((eq? obj '#t)
  137.          (write-int stream header/true))
  138.         (else
  139.          (error "bad immediate type ~s" obj))))
  140.  
  141. (define-integrable (write-data stream int)
  142.   (write-int stream (fx+ pure-size int)))
  143.  
  144. (define-integrable (write-int stream int)
  145.   (write-half stream (fixnum-ashr int 16))
  146.   (write-half stream int))
  147.  
  148. (define (write-half stream int)
  149.   (write-byte stream (fixnum-ashr int 8))
  150.   (write-byte stream int))
  151.  
  152. (define-integrable (write-byte stream n)
  153.   (writec stream (ascii->char (fixnum-logand n 255))))
  154.                                  
  155. (define-integrable (write-fixnum stream fixnum)
  156.   (write-half stream (fixnum-ashr fixnum 14))
  157.   (write-half stream (fixnum-ashl fixnum 2)))
  158.  
  159.  
  160. (define (write-link-file stream)
  161.   (set reloc-length (enforce (lambda (x) (<= x #xffff))
  162.                  (length (lstate-data-reloc *lstate*))))
  163.   (modify (lstate-symbols *lstate*) reverse!)
  164.   (pad-area (lstate-pure *lstate*))
  165.   (pad-area (lstate-impure *lstate*))
  166.   (set pure-size (area-frontier (lstate-pure *lstate*)))
  167.   (write-header     stream)
  168.   (write-aouthdr stream)
  169.   (write-text-section-header stream)
  170.   (write-data-section-header stream)
  171.   (write-area       stream (lstate-pure *lstate*))
  172.   (write-area       stream (lstate-impure *lstate*))
  173.   (write-relocation stream)
  174.   (receive (i aligned-i) (make-stryng-table)
  175.     (write-cymbal-table-header stream aligned-i)
  176.     (write-hack-local-symbol stream)
  177.     (write-hack-local-string stream)
  178.     (write-stryng-table stream (fx- aligned-i i)))
  179.   (write-hack-file-descriptor stream)
  180.   (write-cymbal-table stream))
  181.  
  182. (define (write-header stream)
  183.     (write-half stream MAGIC)                 ;magic number
  184.     (write-half stream 2)                     ; # of sections
  185.     (write-int stream 0)                      ; time and date 
  186.     (write-int stream (cymbal-table-offset))
  187.     (write-int stream #x60)        ;size of symbol header
  188.     (write-half stream #x38)                      ; size of a.out header
  189.     (write-half stream 0))        ;flags
  190.  
  191. (define (write-aouthdr stream)
  192.   (write-half stream #x107)        ;magic
  193.   (write-half stream #x11f)        ;version stamp
  194.   (write-int stream (text-size))    ;text size
  195.   (write-int stream (data-size))    ;data size
  196.   (write-int stream 0)            ;bss size
  197.   (write-int stream 0)            ;entry
  198.   (write-int stream 0)            ;text base
  199.   (write-int stream (text-size))    ;data base
  200.   (write-int stream (+ (text-size) (data-size))) ;bss base
  201.   (write-int stream 0)            ;register mask
  202.   (write-int stream 0)            ;cp mask [4]
  203.   (write-int stream 0)
  204.   (write-int stream 0)
  205.   (write-int stream 0)
  206.   (write-int stream #x8010))        ;gp value ???
  207.  
  208.  
  209. (define (write-text-section-header stream)   
  210.   (write-string stream ".text")
  211.   (write-byte stream 0)
  212.   (write-byte stream #x20)
  213.   (write-byte stream #x20)
  214.   (write-int stream 0)      ; phys addr
  215.   (write-int stream 0)      ; virtual addr
  216.   (write-int stream (text-size))    
  217.   (write-int stream (headers-size))    ;offset in file
  218.   (write-int stream 0)      ; no reloc
  219.   (write-int stream 0)      ; no gp table
  220.   (write-int stream 0)      
  221.   (write-int stream #x20))
  222.   
  223. (define (write-data-section-header stream)   
  224.   (write-string stream ".data")
  225.   (write-byte stream 0)
  226.   (write-byte stream #x20)
  227.   (write-byte stream #x20)
  228.   (write-int stream (text-size))      ; phys addr
  229.   (write-int stream (text-size))      ; virtual addr
  230.   (write-int stream (data-size))    
  231.   (write-int stream (+ (text-size) (headers-size)))    ;offset in file
  232.   (write-int stream (+ (headers-size) (text-size) (data-size)))    ;  reloc
  233.   (write-int stream 0)      ; no gp table
  234.  
  235.   (write-half stream reloc-length)
  236.   (write-half stream 0)            ;no gp tables
  237.   (write-int stream #x40))
  238.  
  239. (define (headers-size) (fx* 39 4))
  240. (define (text-size) (area-frontier (lstate-pure *lstate*)))
  241. (define (data-size) (area-frontier (lstate-impure *lstate*)))
  242.  
  243. (define (cymbal-table-offset)
  244.   (+ (headers-size) (text-size) (data-size)
  245.      (* RELOC-SIZE reloc-length)))
  246.  
  247. (define (write-area stream area)
  248.   (walk (lambda (x) (write-store x stream))
  249.         (reverse! (area-objects area))))
  250.  
  251.  
  252. (define (write-relocation stream)
  253.   (walk (lambda (item)
  254.       (destructure (((addr . (lw .  hb)) item))
  255.         (write-data stream (car item))
  256.         (write-byte stream 0)
  257.         (write-half stream lw)
  258.         (write-byte stream hb)))
  259.         (sort-list! (lstate-data-reloc *lstate*)
  260.                     (lambda (x y)      
  261.                        (fx< (car x) (car y))))))
  262.  
  263.  
  264. (define (write-map-entry stream name value) nil)
  265.  
  266. (define (write-cymbal-table-header stream string-table-size)
  267.   (write-half stream #x7009)        ;magic
  268.   (write-half stream #x11f)        ;vstamp
  269.   (write-long-zeros stream 7)
  270.   (write-int stream 2)            ;number of local symbols
  271.   (write-int stream (+ (cymbal-table-offset) #x60))
  272.   (write-long-zeros stream 4)
  273.   (write-int stream 8)            ;max index in local strings
  274.   (write-int stream (+ (cymbal-table-offset) #x60 24))
  275.   (write-int stream string-table-size)    ;max string-index
  276.   (write-int stream (+ (cymbal-table-offset) #x60 8 24)) ;string table begin
  277.   (write-int stream 1)            ;fd entries
  278.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size))
  279.   (write-long-zeros stream 2)
  280.   (write-int stream (lstate-symbol-count *lstate*)) ;max symbol index
  281.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size 72)))
  282.  
  283. (define (write-hack-local-symbol stream)
  284.   (write-int stream 1)
  285.   (write-int stream 0)
  286.   (write-half stream #x2c20)
  287.   (write-half stream 2)
  288.   (write-int stream 1)
  289.   (write-int stream 0)
  290.   (write-half stream #x2020)
  291.   (write-half stream 0))
  292.  
  293. (define (write-hack-local-string stream)
  294.   (write-byte stream 0)
  295.   (write-string stream "foo.s")
  296.   (write-byte stream 0)
  297.   (write-byte stream 0))
  298.  
  299. (define (write-hack-file-descriptor stream)
  300.   (walk (lambda (x) (write-int stream x))
  301.     '(0 1 0 7 0 2 0 0 0 0 0 0 0 0 0))
  302.   (write-half stream #x1d80)
  303.   (write-half stream 0)
  304.   (write-int stream 0)
  305.   (write-int stream 0))
  306.  
  307. (define (write-long-zeros stream n)
  308.   (do ((i n (fx- i 1)))
  309.       ((fx= i 0))
  310.     (write-int stream 0)))
  311.  
  312. (define (write-cymbal-table stream)
  313.   (walk (lambda (cym) (cym stream)) (lstate-symbols *lstate*)))
  314.  
  315. (define (make-stryng-table)
  316.   (set the-string-table (make-string-table 'stryngs))
  317.   (iterate loop ((i 0) (cyms (lstate-symbols *lstate*)))
  318.       (cond ((null? cyms) (return i (align i 2)))
  319.             (else
  320.              (let* ((string (cymbal-thunk.stryng (car cyms)))
  321.                     (len (string-length string)))
  322.            (set (table-entry the-string-table string) i)
  323.            (loop (fx+ i (fx+ len 1)) (cdr cyms)))))))
  324.                                                        
  325.  
  326. (define (write-stryng-table stream extra)
  327.   (walk (lambda (cym)
  328.       (write-string stream (cymbal-thunk.stryng cym))
  329.       (write-byte stream 0))
  330.     (lstate-symbols *lstate*))
  331.   (do ((extra extra (fx- extra 1)))
  332.       ((fx= extra 0))
  333.     (write-byte stream 0)))
  334.  
  335.  
  336. (define (pad-area area)
  337.   (let ((rem (fixnum-remainder (area-frontier area) 16)))
  338.     (cond ((fxn= rem 0)
  339.        (modify (area-frontier area)
  340.            (lambda (x) (fx+ x (fx- 16 rem))))
  341.        (do ((i (fx- 16 rem) (fx- i 4)))
  342.            ((fx= i 0))
  343.          (push (area-objects area)
  344.            (object nil
  345.              ((write-store self stream)
  346.               (write-int stream 0)))))))))